home *** CD-ROM | disk | FTP | other *** search
/ PC World Interactive 7 / PC World Interactive 7.iso / share / multimed / myflix_win32 / myflix_win32.exe / data1.cab / Libraries / tk8.0 / Safetk.tcl < prev    next >
Text File  |  1998-03-10  |  5KB  |  146 lines
  1. # safetk.tcl --
  2. #
  3. # Support procs to use Tk in safe interpreters.
  4. #
  5. # SCCS: @(#) safetk.tcl 1.6 97/08/13 16:08:18
  6. #
  7. # Copyright (c) 1997 Sun Microsystems, Inc.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  
  12. # see safetk.n for documentation
  13.  
  14. #
  15. #
  16. # Note: It is UNSAFE to let any untrusted code being executed
  17. #       between the creation of the interp and the actual loading
  18. #       of Tk in that interp.
  19. #       You should "loadTk $slave" right after safe::tkInterpCreate
  20. #       Otherwise, if you are using an application with Tk
  21. #       and don't want safe slaves to have access to Tk, potentially
  22. #       in a malevolent way, you should use 
  23. #            ::safe::interpCreate -nostatics -accesspath {directories...}
  24. #       where the directory list does NOT contain any Tk dynamically
  25. #       loadable library
  26. #
  27.  
  28. # We use opt (optional arguments parsing)
  29. package require opt 0.1;
  30.  
  31. namespace eval ::safe {
  32.  
  33.     # counter for safe toplevels
  34.     variable tkSafeId 0;
  35.  
  36.     #
  37.     # tkInterpInit : prepare the slave interpreter for tk loading
  38.     #
  39.     # returns the slave name (tkInterpInit does)
  40.     #
  41.     proc ::safe::tkInterpInit {slave} {
  42.     global env tk_library
  43.     if {[info exists env(DISPLAY)]} {
  44.         $slave eval [list set env(DISPLAY) $env(DISPLAY)];
  45.     }
  46.     # there seems to be an obscure case where the tk_library
  47.     # variable value is changed to point to a sym link destination
  48.     # dir instead of the sym link itself, and thus where the $tk_library
  49.     # would then not be anymore one of the auto_path dir, so we use
  50.     # the addToAccessPath which adds if it's not already in instead
  51.     # of the more conventional findInAccessPath
  52.     ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]
  53.     return $slave;
  54.     }
  55.  
  56.  
  57. # tkInterpLoadTk : 
  58. # Do additional configuration as needed (calling tkInterpInit) 
  59. # and actually load Tk into the slave.
  60. # 
  61. # Either contained in the specified windowId (-use) or
  62. # creating a decorated toplevel for it.
  63.  
  64. # empty definition for auto_mkIndex
  65. proc ::safe::loadTk {} {}
  66.    
  67.     ::tcl::OptProc loadTk {
  68.     {slave -interp "name of the slave interpreter"}
  69.     {-use  -windowId {} "window Id to use (new toplevel otherwise)"}
  70.     } {
  71.     if {![::tcl::OptProcArgGiven "-use"]} {
  72.         # create a decorated toplevel
  73.         ::tcl::Lassign [tkTopLevel $slave] w use;
  74.         # set our delete hook (slave arg is added by interpDelete)
  75.         Set [DeleteHookName $slave] [list tkDelete {} $w];
  76.     }
  77.     tkInterpInit $slave;
  78.     ::interp eval $slave [list set argv [list "-use" $use]];
  79.     ::interp eval $slave [list set argc 2];
  80.     load {} Tk $slave
  81.     return $slave
  82.     }
  83.  
  84.     proc ::safe::tkDelete {W window slave} {
  85.     # we are going to be called for each widget... skip untill it's
  86.     # top level
  87.     Log $slave "Called tkDelete $W $window" NOTICE;
  88.     if {[::interp exists $slave]} {
  89.         if {[catch {::safe::interpDelete $slave} msg]} {
  90.         Log $slave "Deletion error : $msg";
  91.         }
  92.     }
  93.     if {[winfo exists $window]} {
  94.         Log $slave "Destroy toplevel $window" NOTICE;
  95.         destroy $window;
  96.     }
  97.     }
  98.  
  99. proc ::safe::tkTopLevel {slave} {
  100.     variable tkSafeId;
  101.     incr tkSafeId;
  102.     set w ".safe$tkSafeId";
  103.     if {[catch {toplevel $w -class SafeTk} msg]} {
  104.     return -code error "Unable to create toplevel for\
  105.         safe slave \"$slave\" ($msg)";
  106.     }
  107.     Log $slave "New toplevel $w" NOTICE
  108.  
  109.     set msg "Untrusted Tcl applet ($slave)"
  110.     wm title $w $msg;
  111.  
  112.     # Control frame
  113.     set wc $w.fc
  114.     frame $wc -bg red -borderwidth 3 -relief ridge ;
  115.  
  116.     # We will destroy the interp when the window is destroyed
  117.     bindtags $wc [concat Safe$wc [bindtags $wc]]
  118.     bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave];
  119.  
  120.     label $wc.l -text $msg \
  121.         -padx 2 -pady 0 -anchor w;
  122.  
  123.     # We want the button to be the last visible item
  124.     # (so be packed first) and at the right and not resizing horizontally
  125.  
  126.     # frame the button so it does not expand horizontally
  127.     # but still have the default background instead of red one from the parent
  128.     frame  $wc.fb -bd 0 ;
  129.     button $wc.fb.b -text "Delete" \
  130.         -bd 2  -padx 2 -pady 0 \
  131.         -command [list ::safe::tkDelete $w $w $slave]
  132.     pack $wc.fb.b -side right -fill both ;
  133.     pack $wc.fb -side right -fill both -expand 1;
  134.     pack $wc.l -side left  -fill both -expand 1;
  135.     pack $wc -side bottom -fill x ;
  136.  
  137.     # Container frame
  138.     frame $w.c -container 1;
  139.     pack $w.c -fill both -expand 1;
  140.     
  141.     # return both the toplevel window name and the id to use for embedding
  142.     list $w [winfo id $w.c] ;
  143. }
  144.  
  145. }
  146.